The X-Philes (2nd Revision)/The X-Philes Number 1 (1995).iso/xphiles/hp95/ylisp.mis

Internet Message Format | 1992-05-20 | 5KB

From micro-heart-of-gold.mit.edu!wupost!sdd.hp.com!hpscdc!hplextra!hpfcso!hpfcmdd!hpbbrd!peer Thu, 2 Apr 1992 12:40:22 GMT
From: [e-mail] (Peter Ernst)
Date: Thu, 2 Apr 1992 12:40:22 GMT
Subject: Re: LISP for the HP95LX
Message-ID: <[e-mail]>
Organization: HP Mechanical Design Division
Path: micro-heart-of-gold.mit.edu!wupost!sdd.hp.com!hpscdc!hplextra!hpfcso!hpfcmdd!hpbbrd!peer
Newsgroups: comp.sys.palmtops
References: <[e-mail]>

In the ylisp95.zip archive on 'ftp.irisa.fr' there is one important lisp file
missing. You will wind it attached to this mail.

Sorry :-(
       ----- cut here ---------

# This is a shell archive.  Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by Peter Ernst <peer@hpbbrd> on Thu Apr  2 05:38:53 1992
#
# This archive contains:
#    ylisp.lsp
#

LANG=""; export LANG
PATH=/bin:/usr/bin:$PATH; export PATH

echo x - ylisp.lsp
cat >ylisp.lsp <<'@EOF'
(format *standard-output*  "YLISP-Version ~A~%" *version*)

; SYMBOL FUNCTIONS

(defmacro defvar (sym &optional val)
  `(if (boundp ',sym) ,sym (setq ,sym ,val)))
(defmacro defparameter (sym val)
  `(setq ,sym ,val))
(defmacro defconstant (sym val)
  `(setq ,sym ,val))

; (makunbound sym) - make a symbol value be unbound
(defmacro makunbound (sym)
  `(progn (setf (symbol-value ,sym) '*unbound*) ,sym)
)

; (fmakunbound sym) - make a symbol function be unbound
(defmacro fmakunbound (sym)
  `(progn (setf (symbol-function ,sym) '*unbound*) ,sym)
)

; LIST FUNCTIONS

; (mapcan fun list [ list ]...)
(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))

; (mapcon fun list [ list ]...)
(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))

;; The following functionality is implemented as macros for the sake
;; of compatibility with setf

(defmacro caar (list)
  `(cxr ,list "aa")
)
(defmacro cadr (list)
  `(cxr ,list "ad")
)
(defmacro cdar (list)
  `(cxr ,list "da")
)
(defmacro cddr (list)
  `(cxr ,list "dd")
)
(defmacro caaar (list)
  `(cxr ,list "aaa")
)
(defmacro caadr (list)
  `(cxr ,list "aad")
)
(defmacro cadar (list)
  `(cxr ,list "ada")
)
(defmacro caddr (list)
  `(cxr ,list "add")
)
(defmacro cdaar (list)
  `(cxr ,list "daa")
)
(defmacro cdadr (list)
  `(cxr ,list "dad")
)
(defmacro cddar (list)
  `(cxr ,list "dda")
)
(defmacro cdddr (list)
  `(cxr ,list "ddd")
)
(defmacro caaaar (list)
  `(cxr ,list "aaaa")
)
(defmacro caaadr (list)
  `(cxr ,list "aad")
)
(defmacro caadar (list)
  `(cxr ,list "aada")
)
(defmacro caaddr (list)
  `(cxr ,list "aadd")
)
(defmacro cadaar (list)
  `(cxr ,list "adaa")
)
(defmacro cadadr (list)
  `(cxr ,list "adad")
)
(defmacro caddar (list)
  `(cxr ,list "adda")
)
(defmacro cadddr (list)
  `(cxr ,list "addd")
)
(defmacro cdaaar (list)
  `(cxr ,list "daaa")
)
(defmacro cdaadr (list)
  `(cxr ,list "daad")
)
(defmacro cdadar (list)
  `(cxr ,list "dada")
)
(defmacro cdaddr (list)
  `(cxr ,list "dadd")
)
(defmacro cddaar (list)
  `(cxr ,list "ddaa")
)
(defmacro cddadr (list)
  `(cxr ,list "ddad")
)
(defmacro cdddar (list)
  `(cxr ,list "ddda")
)
(defmacro cddddr (list)
  `(cxr ,list "dddd")
)

(defmacro first (list)
  `(car ,list)
)

(defmacro second (list)
  `(cxr ,list "ad")
)

(defmacro third (list)
  `(cxr ,list "add")
)

(defmacro fourth (list)
  `(cxr ,list "addd")
)

(defmacro rest (list)
  `(cdr ,list)
)

; MISC

; (set-macro-character ch fun [ tflag ])
(defun set-macro-character (ch fun &optional tflag)
    (setf (aref *readtable* (char-int ch))
          (cons (if tflag :tmacro :nmacro) fun))
    t)

; (get-macro-character ch)
(defun get-macro-character (ch)
  (if (consp (aref *readtable* (char-int ch)))
    (cdr (aref *readtable* (char-int ch)))
    nil))

; SYSTEM FUNCTIONS

; (save-def fun) - save a function definition to a file
(defmacro save-def (name &aux
                         (fname (strcat (symbol-name name) ".lsp"))
                         (stream (open fname :direction :output)))

  (if stream `(progn (pp-def ,name ,stream)
                     (close ,stream)
                     ,fname)
     (nil))

)

; (debug) - enable debug breaks
(defun debug (s)
       (setq *breakenable* s))

; initialize to enable breaks but no trace back
(setq *breakenable* t)
(setq *tracenable* nil)

; INPUT/OUTPUT FUNCTIONS

(DEFUN PP-FILE (FILENAME &OPTIONAL STREAMOUT)
  (OR STREAMOUT (SETQ STREAMOUT *STANDARD-OUTPUT*))
  (PRINC "; Listing of " STREAMOUT)
  (PRINC FILENAME STREAMOUT)
  (TERPRI STREAMOUT)
  (TERPRI STREAMOUT)
  (DO* ( (FP (OPEN FILENAME))
         (EXPR (READ FP) (READ FP)))
       ((NULL EXPR) (CLOSE FP))
       (PPRINT EXPR STREAMOUT)
       (TERPRI STREAMOUT)))


; Print a lambda or macro form as a DEFUN or DEFMACRO:

(DEFMACRO PP-DEF (NAME &OPTIONAL STREAM
                       &AUX (EXPR (get-lambda-expression
                                   (symbol-function name))))
  `(pprint
    ',(nconc (list (if (eq (car expr) 'LAMBDA) 'DEFUN 'DEFMACRO)
                  name)
            (cdr expr))
    ,@(if stream (list stream))))

(defconstant pi 3.14159265358979323846)

;; now load the user's startup file

(load "startup")
@EOF

chmod 440 ylisp.lsp

exit 0